home *** CD-ROM | disk | FTP | other *** search
- External;
-
- {
- Declarations.p (of PCQ Pascal)
- Copyright (c) 1989 Patrick Quaid
-
- Generally speaking, this module handles the various
- declarations. The major exception to this is doblock(), in main.p,
- which might be considered a declaration.
- }
-
- {$O-}
- {$I "Pascal.i"}
-
- Function EnterStandard( st_Name : String;
- st_Object : IDObject;
- st_Type : TypePtr;
- st_Storage : IDStorage;
- st_Offset : Integer) : IDPtr;
- external;
- Function EnterSpell(Str : String) : String;
- external;
- Function Match(i : Symbols): boolean;
- external;
- Procedure Error(s : string);
- external;
- Function ConExpr(VAR ConType : TypePtr): Integer;
- external;
- Function AddType(at_Object : TypeObject;
- at_SubType : TypePtr;
- at_Ref : Address;
- at_Upper,
- at_Lower,
- at_Size : Integer) : TypePtr;
- external;
-
- procedure ns;
- external;
- Function TypeCmp(f, s : TypePtr): Boolean;
- external;
- Function FindID(s: string): IDPtr;
- external;
- function CheckID(s : string): IDPtr;
- external;
- Function CheckIDList(s : String; ID : IDPtr) : Boolean;
- external;
- Procedure EnterID(EntryBlock : BlockPtr; ID : IDPtr);
- external;
- procedure NextSymbol;
- external;
- Procedure NeedLeftParent;
- External;
- procedure NeedRightParent;
- external;
- Procedure Mismatch;
- External;
- Procedure DumpLitQ(Start : Integer);
- External;
- Procedure WriteHex(num : Integer);
- External;
- Function TypeCheck(T1, T2 : TypePtr) : Boolean;
- External;
- Function GetLabel : Integer;
- External;
- Function Suffix(Size : Integer) : Char;
- External;
- Procedure PrintLabel(lab : Integer);
- External;
-
-
- Function DeclVar(ob : IDObject) : IDPtr;
- forward;
-
- Procedure ReformArgs(ProcID : IDPtr);
-
- {
- This is the first in a series of routines that assigns the
- proper addresses to procedure or function arguments.
- }
-
- var
- TotalSize : Integer;
- ID : IDPtr;
- begin
- ID := ProcID^.Param;
- if ProcID^.Level = 1 then
- TotalSize := 8
- else
- TotalSize := 12;
- While ID <> Nil do begin
- if ID^.Object = ValArg then begin
- TotalSize := TotalSize + ID^.VType^.Size;
- if Odd(TotalSize) then
- TotalSize := Succ(TotalSize);
- end else
- TotalSize := TotalSize + 4;
- ID := ID^.Next;
- end;
- ID := ProcID^.Param;
- while ID <> Nil do begin
- if ID^.Object = ValArg then begin
- TotalSize := TotalSize - ID^.VType^.Size;
- if Odd(TotalSize) then begin
- if ID^.VType^.Size = 1 then begin
- ID^.Offset := TotalSize;
- TotalSize := Pred(TotalSize);
- end else begin
- TotalSize := Pred(TotalSize);
- ID^.Offset := TotalSize;
- end;
- end else
- ID^.Offset := TotalSize;
- end else begin { RefArg }
- TotalSize := TotalSize - 4;
- ID^.Offset := TotalSize;
- end;
- ID := ID^.Next;
- end;
- end;
-
- Function ReformFields(ID : IDPtr) : Integer;
-
- {
- ...Determines the proper offsets of the fields, and returns the
- total size of the record.
- }
- var
- TotalSize : Integer;
- begin
- TotalSize := 0;
- while ID <> Nil do begin
- if Odd(TotalSize) and (ID^.VType^.Size <> 1) then
- TotalSize := Succ(TotalSize);
- ID^.Offset := TotalSize;
- TotalSize := TotalSize + ID^.VType^.Size;
- ID := ID^.Next;
- end;
- ReformFields := TotalSize;
- end;
-
- Function GetRange() : TypePtr;
- var
- TP : TypePtr;
- IndexType1,
- IndexType2 : TypePtr;
- Hold,
- Lo, Hi : Integer;
- begin
- New(TP);
- TP^.Object := ob_subrange;
- Lo := ConExpr(IndexType1);
- if not Match(DotDot1) then
- error("expecting '..' here");
- Hi := ConExpr(IndexType2);
- if not TypeCheck(IndexType1, IndexType2) then begin
- Error("Incompatible range types");
- IndexType1 := BadType;
- end;
- if Lo > Hi then begin
- Error("Lower bound greater than upper bound");
- Hold := Hi;
- Hi := Lo;
- Lo := Hold;
- end;
- GetRange := AddType(ob_subrange, IndexType1, IndexType1,
- Hi, Lo, IndexType1^.Size);
- end;
-
- Function DeclArgs(ob : IDObject) : IDPtr;
- forward;
-
- Function ReadRecord(): TypePtr;
-
- {
- This just reads a record.
- }
- var
- Size : Integer;
- TP : TypePtr;
- begin
- TP := AddType(ob_record, Nil, Nil, 0, 0, 0);
- if TypeID <> Nil then
- TypeID^.VType := TP;
- TP^.Ref := DeclArgs(field);
- if not match(end1) then
- error("Missing END of record");
- TP^.Size := ReformFields(TP^.Ref);
- ReadRecord := TP;
- end;
-
- Function ReadEnumeration(): TypePtr;
-
- {
- This just reads enumerations and assigns them numbers
- starting with zero. The size of an enumerated type is either 1
- or two bytes: Enumerations with > 127 items are contained in 2.
- }
-
- var
- Position : Integer;
- EnumType : TypePtr;
- ID : IDPtr;
- begin
- Position := 0;
- EnumType := AddType(ob_ordinal, Nil, Nil, 0, 0, 0);
- While CurrSym = Ident1 do begin
- if CheckID(SymText) <> Nil then
- Error("Duplicate ID");
- ID := EnterStandard(SymText, constant, EnumType, st_none, Position);
- Position := Succ(Position);
- NextSymbol;
- if CurrSym <> RightParent1 then
- if not Match(Comma1) then
- Error("Missing Comma");
- end;
- if Position <= 256 then { Position = # of enumerations + 1 }
- EnumType^.Size := 1
- else
- EnumType^.Size := 2;
- NeedRightParent;
- ReadEnumeration := EnumType;
- end;
-
- Function ReadType : TypePtr;
- Forward;
-
- Function DefineArray : TypePtr;
- var
- TP, TP2,
- LastType : TypePtr;
- ID : IDPtr;
-
- Function DeclareDimension : TypePtr;
- var
- TP : TypePtr;
- begin
- TP := GetRange;
- with TP^ do begin
- Ref := SubType;
- Object := ob_array;
- if Match(Comma1) then
- SubType := DeclareDimension
- else
- SubType := Nil;
- end;
- DeclareDimension := TP;
- end;
-
- Procedure FixArraySize(TP : TypePtr);
- begin
- if TP^.Object = ob_array then begin
- FixArraySize(TP^.SubType);
- TP^.Size := TP^.SubType^.Size * (TP^.Upper - TP^.Lower + 1);
- end;
- end;
-
- begin
- if Match(LeftBrack1) then begin
- TP := DeclareDimension;
- LastType := TP;
- While LastType^.SubType <> Nil do
- LastType := LastType^.SubType; { Get the last array dim }
- if not Match(RightBrack1) then
- error("Expecting a right bracket");
- end else if CurrSym = Ident1 then begin
- ID := FindID(SymText);
- NextSymbol;
- if ID = Nil then begin
- error("Unknown ID");
- TP := BadType;
- end else if ID^.Object <> obtype then begin
- error("Expecting a type");
- TP := BadType;
- end else if ID^.VType^.Object <> ob_subrange then begin
- error("Expecting a range");
- TP := BadType;
- end else
- TP := ID^.VType;
- New(TP2);
- TP2^ := TP^;
- TP := TP2;
- TP^.Next := CurrentBlock^.FirstType;
- CurrentBlock^.FirstType := TP;
- LastType := TP;
- end else begin
- error("Expecting range");
- New(TP);
- TP^ := BadType^;
- LastType := TP;
- end;
- TP^.Object := ob_array;
- if not match(of1) then
- error("expecting OF");
- LastType^.SubType := ReadType;
- FixArraySize(TP);
- DefineArray := TP;
- end;
-
- Function ReadType(): TypePtr;
-
- {
- This routine creates and returns a type record produced
- by a normal type declaration. Note that this function is used
- almost everywhere a type is called for, so you can use a full type
- description in most places.
- }
-
- var
- TP : TypePtr;
- ID : IDPtr;
- Length : Integer;
- begin
- if currsym = ident1 then begin
- ID := FindID(symtext);
- if ID = Nil then begin
- Error("Unknown ID");
- TP := BadType;
- NextSymbol;
- end else if ID^.Object = obtype then begin
- TP := ID^.VType;
- NextSymbol;
- { if Match(LeftBrack1) and (TP = StringType) then begin
- Length := ConExpr(TP);
- if TypeCheck(TP,IntType) then begin
- if Length < 0 then
- Error("String length must be positive");
- TP := AddType(ob_prestring, CharType, Nil, Pred(Length), 0, Length);
- end else begin
- Error("Expecting an integer length");
- TP := BadType;
- end;
- if not Match(RightBrack1) then
- Error("Missing ]");
- end; }
- end else if ID^.Object = constant then
- TP := GetRange()
- else begin
- Error("Expecting a TYPE");
- TP := BadType;
- NextSymbol;
- end;
- end else if (CurrSym = Numeral1) or (CurrSym = Apostrophe1) then
- TP := GetRange()
- else if match(carat1) then begin
- TP := ReadType();
- TP := AddType(ob_pointer, TP, nil, 0, 0, 4);
- end else if match(leftparent1) then
- TP := ReadEnumeration()
- else if match(array1) then
- TP := DefineArray
- else if match(record1) then begin
- TP := ReadRecord();
- end else if match(file1) then begin
- if not match(of1) then
- error("expecting OF");
- TP := ReadType();
- TP := AddType(ob_file, TP, nil, TP^.Size, 0, 32);
- end else begin
- error("unknown type of thing");
- TP := BadType;
- end;
- readtype := TP;
- end;
-
- Procedure DeclType;
-
- {
- This handles a type declaration block.
- }
- begin
- While CurrSym = ident1 do begin
- if CheckID(SymText) <> nil then
- error("duplicate id");
- TypeID := EnterStandard(SymText, obtype, BadType, st_none, 0);
- NextSymbol;
- if not Match(equal1) then
- Error("expecting '=' here");
- TypeID^.VType := ReadType();
- ns;
- end;
- TypeID := Nil;
- end;
-
- Function DeclArgs(ob : IDObject) : IDPtr;
-
- Procedure DeclArgList(var VarList : IDPtr; ob : IDObject);
- var
- ID,
- RunID : IDPtr;
- begin
- if CurrSym = Ident1 then begin
- if CheckIDList(SymText, VarList) then
- error("Duplicate Parameter Name");
- New(ID);
- ID^.Name := EnterSpell(SymText);
- ID^.Object := ob;
- ID^.Next := Nil;
- if VarList = Nil then
- VarList := ID
- else begin
- RunID := VarList;
- while RunID^.Next <> Nil do
- RunID := RunID^.Next;
- RunID^.Next := ID;
- end;
- NextSymbol;
- if Match(Comma1) then begin
- DeclArgList(VarList, ob);
- ID^.VType := ID^.Next^.VType;
- end else begin
- if not Match(colon1) then
- error("Expecting a colon");
- ID^.VType := ReadType();
- end;
- if (ob = valarg) and (ID^.VType^.Object = ob_file) then
- error("Files must be VAR parameters");
- end;
- end;
-
- var
- ID : IDPtr;
-
- begin
- ID := Nil;
- if ob = field then begin
- While CurrSym = Ident1 do begin
- DeclArgList(ID, field);
- ns;
- end;
- end else begin
- while (CurrSym = Ident1) or (CurrSym = Var1) do begin
- if Match(Var1) then
- DeclArgList(ID, refarg)
- else
- DeclArgList(ID, valarg);
- if CurrSym <> RightParent1 then
- ns;
- end;
- end;
- DeclArgs := ID;
- end;
-
- Function DeclVar(ob : IDObject) : IDPtr;
-
- {
- This is used to declare a local or global variable.
- }
-
- var
- ID,
- NextID : IDPtr;
- TP : TypePtr;
- begin
- if currsym = ident1 then begin
- if CheckID(symtext) <> Nil then
- error("Duplicate id");
- ID := EnterStandard(symtext, ob, BadType, StandardStorage, 0);
- NextSymbol;
- if match(comma1) then begin
- NextID := DeclVar(ob);
- ID^.VType := NextID^.VType;
- end else begin
- if not match(colon1) then
- error("expecting :");
- ID^.VType := ReadType();
- end;
- if ob = local then begin
- StackSpace := StackSpace + ID^.VType^.Size;
- if Odd(StackSpace) and (ID^.VTYpe^.Size <> 1) then
- StackSpace := Succ(StackSpace);
- ID^.Offset := -StackSpace;
- end;
- end else begin
- error("expecting an identifier");
- if CurrSym = Colon1 then
- TP := ReadType()
- else if match(colon1) then
- TP := ReadType();
- end;
- DeclVar := ID;
- end;
-
- Procedure VarDeclarations;
-
- {
- This handles a variable declaration block.
- }
- var
- ID : IDPtr;
- begin
- While CurrSym = ident1 do begin
- if CurrentBlock^.Level = 1 then begin
- ID := DeclVar(global);
- ns;
- end else begin
- ID := DeclVar(local);
- ns;
- end;
- end;
- end;
-
- Function TypedConstant(TP : TypePtr) : Integer;
- var
- DefineIt : Boolean;
-
- Function TypedOrdinal(TP : TypePtr) : Integer;
- var
- ExprType : TypePtr;
- ExprVal : Integer;
- begin
- ExprVal := ConExpr(ExprType);
- if DefineIt then
- Writeln(OutFile, '\tdc.', Suffix(TP^.Size), '\t', ExprVal);
- if not TypeCheck(ExprType, TP) then
- Mismatch;
- TypedOrdinal := ExprVal;
- end;
-
- Function TypedArray(TP : TypePtr) : Integer;
- var
- ExprType : TypePtr;
- ExprVal : Integer;
- Column : Short;
- Current : Integer;
- begin
- if TypeCheck(TP^.SubType, CharType) then begin { special }
- ExprVal := ConExpr(ExprType);
- if not TypeCheck(ExprType, TP) then
- MisMatch;
- if DefineIt then
- DumpLitQ(ExprVal);
- LitPtr := ExprVal;
- TypedArray := 1;
- end else if TP^.SubType^.Object = ob_ordinal then begin
- NeedLeftParent;
- Column := 0;
- if DefineIt then
- Write(OutFile, '\tdc.', Suffix(TP^.SubType^.Size), '\t');
- for Current := 1 to TP^.Upper - TP^.Lower + 1 do begin
- ExprVal := ConExpr(ExprType);
- if not TypeCheck(ExprType, TP^.SubType) then
- Mismatch;
- if DefineIt then begin
- if Column > 60 then begin
- Write(OutFile, '\n\tdc.', Suffix(TP^.SubType^.Size), '\t');
- Column := 0;
- end;
- if Column > 0 then
- Write(OutFile, ',');
- Write(OutFile, ExprVal);
- Column := Column + ExprType^.Size * 3;
- end;
- if CurrSym <> RightParent1 then
- if not Match(Comma1) then
- Error("Expecting a comma");
- end;
- if DefineIt then
- Writeln(OutFile);
- NeedRightParent;
- TypedArray := 1;
- end else begin
- NeedLeftParent;
- for Current := 1 to TP^.Upper - TP^.Lower + 1 do begin
- ExprVal := TypedConstant(TP^.SubType);
- if CurrSym <> RightParent1 then
- if not match(Comma1) then
- Error("Expecting a comma");
- end;
- NeedRightParent;
- TypedArray := 1;
- end;
- end;
-
- Function TypedPointer(TP : TypePtr) : Integer;
- var
- ID : IDPtr;
- ExprVal : Integer;
- ExprType : TypePtr;
- begin
- if Match(At1) then begin
- if CurrSym = Ident1 then begin
- ID := FindID(SymText);
- if (ID^.Object = Global) or
- (ID^.Object = typed_const) then begin
- if DefineIt then begin
- if ID^.Level <= 1 then
- Writeln(OutFile, '\tdc.l\t_', ID^.Name)
- else
- Writeln(OutFile, '\tdc.l\t_', ID^.Name,
- '%', ID^.Unique);
- end;
- if not TypeCheck(TP^.SubType, ID^.VType) then
- MisMatch;
- end else
- Error("Expecting a global identifier");
- NextSymbol;
- end else
- Error("Expecting an identifier");
- TypedPointer := 1;
- end else begin
- ExprVal := ConExpr(ExprType);
- if not TypeCheck(ExprType, TP) then
- Mismatch;
- if DefineIt then begin
- if ExprType = StringType then begin
- Write(OutFile, '\tdc.l\t');
- PrintLabel(LitLab);
- Writeln(OutFile, '+', ExprVal);
- end else
- Writeln(OutFile, '\tdc.l\t', ExprVal);
- end else
- LitPtr := ExprVal;
- TypedPointer := ExprVal;
- end;
- end;
-
- Function TypedRecord(TP : TypePtr) : Integer;
- var
- ID : IDPtr;
- ExprVal : Integer;
- begin
- NeedLeftParent;
- ID := TP^.Ref;
- while ID <> Nil do begin
- ExprVal := TypedConstant(ID^.VType);
- ID := ID^.Next;
- if ID <> Nil then
- if not Match(Comma1) then
- Error("Expecting a comma");
- end;
- NeedRightParent;
- TypedRecord := 1;
- end;
-
- Function TypedReal : Integer;
- var
- ExprVal : Integer;
- ExprType : TypePtr;
- begin
- ExprVal := ConExpr(ExprType);
- if not TypeCheck(ExprType, RealType) then
- MisMatch;
- if DefineIt then begin
- Write(OutFile, '\tdc.l\t');
- WriteHex(ExprVal);
- Writeln(OutFile);
- end;
- TypedReal := ExprVal;
- end;
-
- begin
- DefineIt := StandardStorage <> st_external;
- case TP^.Object of
- ob_ordinal,
- ob_subrange : TypedConstant := TypedOrdinal(TP);
- ob_array : TypedConstant := TypedArray(TP);
- ob_pointer : TypedConstant := TypedPointer(TP);
- ob_record : TypedConstant := TypedRecord(TP);
- ob_real : TypedConstant := TypedReal;
- else
- Error("No typed constants allowed for this type");
- end;
- end;
-
- Procedure DeclConst;
-
- {
- This handles a const declaration block. The grunt work is
- does by conexpr() in expression.p, which is the routine to look at
- if you want to improve constant declarations.
- }
- var
- ID : IDPtr;
- BackName : String;
- TP : TypePtr;
- begin
- While CurrSym = Ident1 do begin
- if CheckID(SymText) <> Nil then
- Error("Duplicate ID");
- ID := EnterStandard(SymText, constant, Nil, st_none, 0);
- BackName := ID^.Name;
- ID^.Name := ""; { So the ID can't be used in the expression }
- NextSymbol;
- if Match(Colon1) then begin
- ID^.VType := ReadType;
- if not Match(Equal1) then
- Error("Missing =");
- if StandardStorage <> st_external then begin
- if ID^.VType^.Size > 1 then
- Writeln(OutFile, '\tCNOP\t0,2');
- if CurrentBlock^.Level <= 1 then begin
- if StandardStorage <> st_private then
- Writeln(OutFile, '\tXDEF\t_', BackName);
- writeln(OutFile, '_', BackName)
- end else begin
- ID^.Unique := GetLabel;
- writeln(OutFile, '_', BackName, '%', ID^.Unique);
- end;
- end;
- ID^.Offset := TypedConstant(ID^.VType);
- ID^.Name := BackName;
- ID^.Object := typed_const;
- if StandardStorage <> st_external then
- ID^.Storage := st_initialized
- else
- ID^.Storage := st_external;
- end else begin
- if not Match(Equal1) then
- Error("Expecting =");
- ID^.Offset := ConExpr(TP);
- ID^.VType := TP;
- ID^.Name := BackName;
- end;
- ns;
- end;
- end;
-
- Procedure DeclLabel;
- {
- This routine accepts a list of identifiers to be used as
- labels in the program. Standard Pascal's labels are four
- digit numbers, but I didn't want to mess with that.
- }
- var
- ID : IDPtr;
- begin
- while CurrSym = Ident1 do begin
- ID := EnterStandard(SymText, lab, Nil, st_none, 0);
- ID^.Unique := GetLabel;
- NextSymbol;
- if not Match(Comma1) then begin
- ns;
- return;
- end;
- end;
- Error("Expecting an identifier");
- end;
-